home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / URI / URL / file.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  2.7 KB  |  126 lines
  1. package URI::URL::file;
  2. require URI::URL::_generic;
  3. @ISA = qw(URI::URL::_generic);
  4.  
  5. require Carp;
  6. require Config;
  7.  
  8. my $os = $Config::Config{'osname'};
  9. OS: {
  10.     $ostype = 'vms', last if $os eq 'VMS';
  11.     $ostype = 'dos', last if $os =~ /^(?:os2|mswin32|msdos)$/i;
  12.     $ostype = 'mac', last if $os eq "Mac";
  13.     $ostype = 'unix';  # The default
  14. }
  15.  
  16.  
  17. sub _parse {
  18.     my($self, $init) = @_;
  19.     $self->URI::URL::_generic::_parse($init, qw(netloc path params frag));
  20. }
  21.  
  22. *local_path = \&{$ostype . "_path"};
  23.  
  24. *query  = \&URI::URL::bad_method;
  25. *equery = \&URI::URL::bad_method;
  26.  
  27. sub newlocal;
  28. sub unix_path;
  29. sub dos_path ;
  30. sub mac_path ;
  31. sub vms_path ;
  32. 1;
  33. __END__
  34.  
  35. sub newlocal {
  36.     my($class, $path) = @_;
  37.  
  38.     Carp::croak("Only implemented for Unix and OS/2 file systems")
  39.       unless $ostype eq "unix" or $^O =~ /os2|mswin32/i;
  40.  
  41.     my $url = new URI::URL "file:";
  42.     unless (defined $path and
  43.             ($path =~ m:^/: or 
  44.          ($^O eq 'os2' and Cwd::sys_is_absolute($path)) or
  45.          ($^O eq 'MSWin32' and $path =~ m<^[A-Za-z]:[\\/]|^[\\/]{2}>))) {
  46.     require Cwd;
  47.     my $cwd = Cwd::fastcwd();
  48.     $cwd =~ s:/?$:/:; # force trailing slash on dir
  49.     $path = (defined $path) ? $cwd . $path : $cwd;
  50.     }
  51.     $url->path($path);
  52.     $url;
  53. }
  54.  
  55. sub unix_path
  56. {
  57.     my $self = shift;
  58.     my @p;
  59.     for ($self->path_components) {
  60.     Carp::croak("Path component contains '/' or '\0'") if m|[\0/]|;
  61.     if (@p) {
  62.         next unless length $_;   # skip empty path segments
  63.         next if $_ eq '.';       # skip these too
  64.         if ($_ eq '..' && $p[-1] ne '..') {  # go up one level
  65.         pop(@p) if $p[-1] ne '';
  66.         next;
  67.         }
  68.     }
  69.     push(@p, $_);
  70.     }
  71.     shift(@p) if @p > 1 && $p[0] eq '.';   # './' rendundant if there is more
  72.     return '/' if !@p || (@p == 1 && $p[0] eq '');
  73.     join('/', @p);
  74. }
  75.  
  76. sub dos_path
  77. {
  78.     my $self = shift;
  79.     my @p;
  80.     for ($self->path_components) {
  81.     Carp::croak("Path component contains '/' or '\\'") if m|[/\\]|;
  82.     push(@p, uc $_);
  83.     }
  84.     my $p = join("\\", @p);
  85.     $p =~ s/^\\([A-Z]:)/$1/;  # Fix drive letter specification
  86.     $p;
  87. }
  88.  
  89. sub mac_path
  90. {
  91.     my $self = shift;
  92.     my @p;
  93.     for ($self->path_components) {
  94.     Carp::croak("Path component contains ':'") if /:/;
  95.     push(@p, $_);
  96.     }
  97.     if (@p && $p[0] eq '') {
  98.     shift @p;
  99.     } else {
  100.     unshift(@p, '');
  101.     }
  102.     join(':', @p);
  103. }
  104.  
  105. sub vms_path
  106. {
  107.  
  108.  
  109.     my $self = shift;
  110.     my @p = $self->path_components;
  111.     my $abs = 0;
  112.     if (@p && $p[0] eq '') {
  113.     shift @p;
  114.     $abs = 1;
  115.     }
  116.     my $p = '';
  117.     $p = uc(shift(@p)) . ":"  if @p && $p[0] =~ /\$/;
  118.     my $file = pop(@p);
  119.     $p .= "[" . join(".", map{uc($_)} @p) . "]" if @p;
  120.     $p .= uc $file;
  121.     $p =~ s/\[/[./ unless $abs;
  122.     $p;
  123. }
  124.  
  125. 1;
  126.